home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / EXPR.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  57KB  |  1,905 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "segment.h"
  15. #include "gvars.h"
  16. #include "attr.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "namp.h"
  20. #include "segmentp.h"
  21. #include "genp.h"
  22. #include "miscp.h"
  23. #include "maincasp.h"
  24. #include "setp.h"
  25. #include "typep.h"
  26. #include "gutilp.h"
  27. #include "arithp.h"
  28. #include "gmiscp.h"
  29. #include "smiscp.h"
  30. #include "chapp.h"
  31. #include "axqrp.h"
  32. #include "exprp.h"
  33.  
  34. static int rat_convert(Const, int *);
  35. void gen_attribute(Node);
  36. static int float_mantissa(int);
  37. static void gen_type_attr(Symbol, int);
  38. static int code_map(Symbol);
  39.  
  40. static int code_map_defined; /* set to FALSE if SETL version yields OM */
  41.  
  42. void gen_value(Node node)                                        /*;gen_value*/
  43. {
  44.     /*
  45.      *  This procedure generates code for the v_expressions
  46.      *  or, in other words, the right-hand-sides.
  47.      *
  48.      *  - node is the tree expression for which code is to be generated.
  49.      */
  50.  
  51.     int    save_tasks_declared, can_convert, rat_int;
  52.     Node    pre_node, rec_type_node, id_node, static_node, init_node, obj_node,
  53.       exception_node, expr_node, init_call_node, task_node, entry_node,
  54.       index_node, value_node, arr_l_bd, arr_h_bd, val_l_bd, val_h_bd;
  55.     Symbol    type_name, node_name, rec_type_name, proc_name, return_type,
  56.       obj_name, obj_type, model_name, exception_name, from_type, to_type,
  57.       accessed_type, discr_name;
  58.     Fortup    ft1;
  59.     Symbol    junk_var, comp_name, indx_type, value_type, indx_value_type;
  60.     Tuple    stmts_list;
  61.     Node    list_node, stmt_node, lhs, comp_node, type_node;
  62.     Tuple    d_l, tup, indx_types;
  63.     Const    value;
  64.     int        i, stmts_list_i, size, ivalue;
  65.     long    exprv; /* fixed point value */
  66.  
  67. #ifdef TRACE
  68.     if (debug_flag) {
  69.         gen_trace_node("GEN_VALUE", node);
  70.     }
  71. #endif
  72.  
  73.     while (N_KIND(node) == as_insert) {
  74.         FORTUP(pre_node = (Node), N_LIST(node), ft1);
  75.             compile(pre_node);
  76.         ENDFORTUP(ft1);
  77.         node = N_AST1(node);
  78.     }
  79.  
  80.     type_name = get_type(node);
  81.  
  82.     if (N_KIND(node) == as_null)
  83.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_null);
  84.     else if (is_simple_name(node)) {
  85.         node_name = N_UNQ(node);
  86.  
  87.         if (is_renaming(node_name)) {
  88.             gen_ks(I_PUSH, mu_addr, node_name);
  89.             if (is_array_type(type_name)) {
  90.                 /* Note: can't be a renaming of a formal parm (transformed */
  91.                 /*       to normal variable). */
  92.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  93.             }
  94.             optional_deref(type_name);
  95.         }
  96.         else if (is_simple_type(type_name)) {
  97.             gen_ks(I_PUSH, kind_of(type_name), node_name);
  98.         }
  99.         else {
  100.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, node_name);
  101.  
  102.             /* Arrays are treated in a different manner, depending on their */
  103.             /* nature: parameters, constants, variables... */
  104.             if (is_array_type(type_name)) {
  105.                 if (is_formal_parameter(node_name)) {
  106.                     /* For a parm, the type template follows the parameter */
  107.                     /* in the stack */
  108.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS,
  109.                       assoc_symbol_get(node_name, FORMAL_TEMPLATE));
  110.                 }
  111.                 else {
  112.                     /* otherwise, the type template address is pushed on the */
  113.                     /* stack */
  114.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  115.                 }
  116.             }
  117.         }
  118.     }
  119.     else {
  120.  
  121.         switch (N_KIND(node) ) {
  122.  
  123.         case(as_create_task):
  124.             gen_s(I_CREATE_TASK, type_name);
  125.             break;
  126.  
  127.         case(as_discard):
  128.             expr_node = N_AST1(node);
  129.             junk_var    = new_unique_name("junk");  /* TBSL: Reusing same var */
  130.             next_local_reference(junk_var);
  131.             gen_ks(I_DECLARE, kind_of(N_TYPE(node)), junk_var);
  132.  
  133.             gen_value(expr_node);
  134.             gen_ksc(I_POP, kind_of(N_TYPE(node)), junk_var,
  135.               "Used only for check");
  136.             break;
  137.  
  138.         case(as_ivalue): 
  139.         case(as_real_literal): 
  140.         case(as_int_literal):
  141.             if (is_fixed_type(type_name)) {
  142.                 exprv = rat_tof(get_ivalue(node),
  143.                   small_of(base_type(type_name)), size_of(type_name));
  144.  
  145.                 /* the evaluation may have raised the overflow flag. Therefore,
  146.                  * constraint_error has to be raised at execution time
  147.                  */
  148.                 if ( ! arith_overflow) {
  149.                     gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  150.                       fixed_const(exprv));
  151.                 }
  152.                 else {
  153.                     gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  154.                     gen(I_RAISE); 
  155.                 }
  156.             }
  157.             else if (is_simple_type(type_name)) {
  158.                 value = get_ivalue(node);
  159.                 if (is_float_type(type_name)) {
  160.                     /* gen_(I_PUSH_IMMEDIATE, kind_of(type_name), value,
  161.                      * ' = '+str(I_TO_F(value)));
  162.                      */
  163.                     if (is_const_rat(value)) { /* try to cnvrt rtnl to real*/
  164.                         chaos("expr.c: rational seen when real expected");
  165.                     }
  166.                     gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), value);
  167.                 }
  168.                 else {
  169.                     if (is_const_rat(value)) { /* try to cnvrt rtnl to int */
  170.                         rat_int = rat_convert(value, &can_convert);
  171.                         if (can_convert) {
  172.                             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  173.                               int_const(rat_int));
  174.                         }
  175.                         else {
  176.                             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), value);
  177.                         }
  178.                     }
  179.                     else if (is_const_uint(value)) {
  180.                         /* try to convert universal integer to integer */
  181.                         ivalue = int_toi(UINTV(value));
  182.                         if (!arith_overflow) {/* if can convert to integer */
  183.                             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  184.                               int_const(ivalue));
  185.                         }
  186.                         else { /* just try again as universal integer */
  187.                             gen_s(I_LOAD_EXCEPTION_REGISTER,
  188.                               symbol_constraint_error);
  189.                             gen(I_RAISE);
  190.                             /* the exceptn has to be raised (overflow on int)
  191.                              * gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  192.                              *    value);
  193.                              */
  194.                         }
  195.                     }
  196.                     else {
  197.                         gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), value);
  198.                     }
  199.                 }
  200.             }
  201.             else 
  202.                 compiler_error("structured ivalue");
  203.             break;
  204.  
  205.         case(as_string_ivalue):
  206.             /*  This created a segment containing the string literal... */
  207.             /* TBSL: note that array_ivalue returns a Segment */
  208.             obj_name  = get_constant_name(array_ivalue(node));
  209.             type_name = N_TYPE(node);
  210.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_name);
  211.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  212.             break;
  213.  
  214.         case(as_index):
  215.             gen_subscript(node);
  216.             optional_deref(type_name);
  217.             break;
  218.  
  219.         case(as_selector):
  220.             gen_address(node);
  221.             optional_deref(type_name);
  222.             break;
  223.  
  224.         case(as_discr_ref):
  225.             discr_name      = N_UNQ(node);
  226.             rec_type_node = N_AST1(node);
  227.             rec_type_name   = N_UNQ(rec_type_node);
  228.             gen_sc(I_PUSH_EFFECTIVE_ADDRESS, rec_type_name,
  229.               "fetch discriminant from template");
  230.             /* SETL version has discr_name as last argument, this is presumably
  231.              * comment part of instruction. For now ignore this
  232.              * gen_ki(I_ADD_IMMEDIATE, mu_word,
  233.              *   TT_C_RECORD_DISCR + FIELD_OFFSET(discr_name)(TARGET),
  234.              *   discr_name);
  235.              */
  236.             /* TBSL: review trnsltn of next line VERY carefully  ds 10-2-85 */
  237.             if (TYPE_KIND(rec_type_name) == TT_D_RECORD) {
  238.                 gen_ki(I_ADD_IMMEDIATE, mu_word,
  239.                   ((sizeof(struct tt_d_type)/sizeof(int)) + 
  240.                   1 + 2 * FIELD_OFFSET(discr_name)));
  241.             }
  242.             else {
  243.                 gen_ki(I_ADD_IMMEDIATE, mu_word,
  244.                   ((sizeof(struct tt_d_type)/sizeof(int))
  245.                   + FIELD_OFFSET(discr_name)));
  246.             }
  247.             gen_k(I_DEREF, kind_of(type_name));
  248.             break;
  249.  
  250.         case(as_all):
  251.             gen_address(node);
  252.             if (is_simple_type(type_name)) {
  253.                 gen_k(I_DEREF, kind_of(type_name));
  254.             }
  255.             else {
  256.                 Symbol not_null;
  257.                 /* test for null explicitly, because optional_deref is a noop
  258.                  * on an array  or record (which are always  references).
  259.                  */
  260.                 gen_k(I_DUPLICATE, mu_addr);
  261.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_null);
  262.                 gen_k(I_COMPARE, mu_addr);
  263.                 not_null = new_unique_name("ok_access");
  264.                 gen_s(I_JUMP_IF_FALSE, not_null);
  265.                 gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  266.                 gen(I_RAISE);
  267.                 gen_s(I_LABEL, not_null);
  268.             }
  269.             break;
  270.  
  271.         case(as_call):
  272.             id_node   = N_AST1(node);
  273.             proc_name   = N_UNQ(id_node);
  274.             return_type = TYPE_OF(proc_name);
  275.             gen_kc(I_DUPLICATE, kind_of(return_type), "place holder");
  276.             compile(node);       /* processed from now as a procedure call */
  277.             break;
  278.  
  279.         case(as_slice):
  280.             gen_address(node);
  281.             break;
  282.  
  283.         case(as_raise):
  284.             compile(node);
  285.             break;
  286.  
  287.         case(as_attribute): 
  288.         case(as_range_attribute):
  289.             gen_attribute(node);
  290.             break;
  291.  
  292.         case(as_record_aggregate): 
  293.